Option Explicit
Sub F_Sample036()
    'Microsoft ActiveX Data Objects 2.X Library ]wޥζ
    'Microsoft ADO Ext. 2.X for DDL and Security ]wޥζ
    'ոF_Data.mdb
    Dim myCon      As New ADODB.Connection
    Dim myRst      As ADODB.Recordset
    Dim myCat      As New ADOX.Catalog
    Dim mytbl      As ADOX.Table
    Dim myFld      As ADOX.Column
    Dim myPrp      As ADOX.Property
    Dim i          As Long
    Dim j          As Long
    Dim k          As Long
    Dim myFileName As String
    myFileName = "F_Data.mdb"           'wɮצW
    myCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & ThisWorkbook.Path & "\" & myFileName & ";"
    Set myCat.ActiveConnection = myCon
    With Worksheets
        On Error Resume Next
        Application.DisplayAlerts = False
        .Item("ADO_TABLEDEF").Delete        'RJsPW
        Application.DisplayAlerts = True
        On Error GoTo 0
        .Add.Name = "ADO_TABLEDEF"          'sW檺W
    End With
    'wDC
    Cells(1, 1).Resize(, 5).Value = _
    Array("TBL_NAME", "FLD_NAME", "TYPE", "LEN", "ZERO")
    i = 2
    For Each mytbl In myCat.Tables
      ']ttΪ
        If mytbl.Type <> "TABLE" Then GoTo Label1:
        Cells(i, 1).Value = mytbl.Name
        i = i + 1
        j = i
        Set myRst = myCon.OpenSchema(adSchemaPrimaryKeys, _
        Array(Empty, Empty, mytbl.Name))
        For Each myFld In mytbl.Columns
            With myFld
                k = myCon.OpenSchema(adSchemaColumns, _
                Array(Empty, Empty, mytbl.Name, .Name)) _
                .Fields("ORDINAL_POSITION").Value
                Cells(i, 1).Resize(, 5).Value = _
                Array(k, .Name, GetConstStr_ADO(.Type), .DefinedSize, _
                .Properties("Jet OLEDB:Allow Zero Length").Value) '`ഫ
               'DnKEYjM
                Set myRst = myCon.OpenSchema(adSchemaPrimaryKeys, _
                Array(Empty, Empty, mytbl.Name))
                Do Until myRst.EOF
                    If myRst.Fields("ORDINAL").Value = k Then
                        Cells(i, 6).Value = "P"
                        myRst.MoveFirst
                        Exit Do
                    End If
                    myRst.MoveNext
                Loop
            End With
            i = i + 1
        Next
        Range(Cells(j, 1), Cells(i, 6)).Sort Key1:=Cells(j, 1)
        i = i + 1
Label1:
    Next mytbl
    myCon.Close
    Set myFld = Nothing                 '
    Set mytbl = Nothing
    Set myCat = Nothing
    Set myCon = Nothing
End Sub
Function GetConstStr_ADO(myInt As Integer) As String
    Dim myStr As String
    Select Case myInt
        Case 20: myStr = "adBigInt"
        Case 128: myStr = "adBinary"
        Case 11: myStr = "adBoolean"
        Case 8: myStr = "adBSTR"
        Case 136: myStr = "adChapter"
        Case 129: myStr = "adChar"
        Case 6: myStr = "adCurrency"
        Case 7: myStr = "adDate"
        Case 133: myStr = "adDBDate"
        Case 134: myStr = "adDBTime"
        Case 135: myStr = "adDBTimeStamp"
        Case 14: myStr = "adDecimal"
        Case 5: myStr = "adDouble"
        Case 0: myStr = "adEmpty"
        Case 10: myStr = "adError"
        Case 64: myStr = "adFileTime"
        Case 72: myStr = "adGUID"
        Case 9: myStr = "adIDispatch"
        Case 3: myStr = "adInteger"
        Case 13: myStr = "adIUnknown"
        Case 205: myStr = "adLongVarBinary"
        Case 201: myStr = "adLongVarChar"
        Case 203: myStr = "adLongVarWChar"
        Case 131: myStr = "adNumeric"
        Case 138: myStr = "adPropVariant"
        Case 4: myStr = "adSingle"
        Case 2: myStr = "adSmallInt"
        Case 16: myStr = "adTinyInt"
        Case 21: myStr = "adUnsignedBigInt"
        Case 19: myStr = "adUnsignedInt"
        Case 18: myStr = "adUnsignedSmallInt"
        Case 17: myStr = "adUnsignedTinyInt"
        Case 132: myStr = "adUserDefined"
        Case 204: myStr = "adVarBinary"
        Case 200: myStr = "adVarChar"
        Case 12: myStr = "adVariant"
        Case 139: myStr = "adVarNumeric"
        Case 202: myStr = "adVarWChar"
        Case 130: myStr = "adWChar"
        Case Else: myStr = "Error"
    End Select
    GetConstStr_ADO = myStr
End Function



